home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / Pascal / Applications / MakeFat 1.0 / PNL Libraries / MyFileSystemUtils.p < prev    next >
Encoding:
Text File  |  1995-11-07  |  14.2 KB  |  566 lines  |  [TEXT/CWIE]
  1. unit MyFileSystemUtils;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Files;
  7.  
  8.     procedure MyResolveAliasFile (var fs: FSSpec);
  9.     function MyGetCatInfo (vrn: integer; dirID: longint; var name: string; index: integer; var pb: CInfoPBRec): OSErr;
  10.     function FSpGetCatInfo (var fs: FSSpec; index: integer; var pb: CInfoPBRec): OSErr;
  11.     function FSpSetCatInfo (var fs: FSSpec; var pb: CInfoPBRec): OSErr;
  12.     function MyFSMakeFSSpec (vrn: integer; dirID: longint; name: Str255; var fs: FSSpec): OSErr;
  13.     procedure MyGetModDate (var fs: FSSpec; var moddate: longint);
  14.     function DuplicateFile (var org, new: FSSpec): OSErr;
  15.     function CopyData (src, dst: integer; len: longint): OSErr;
  16.     function TouchDir (fs: FSSpec): OSErr;
  17.     function TouchFolder (vrn: integer; dirID: longint): OSErr;
  18.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  19.     function MyFSReadLineEOL (refnum: integer; ch: char; var s: Str255): OSErr;
  20.     function MyFSReadLine (refnum: integer; var s: Str255): OSErr;
  21.     function MyFSReadLineAt (refnum: integer; pos: longint; var s: Str255): OSErr;
  22.     function MyFSWrite (refnum: integer; len: longint; p: ptr): OSErr;
  23.     function MyFSWriteAt (refnum: integer; mode: integer; pos, len: longint; p: ptr): OSErr;
  24.     function MyFSReadAt (refnum: integer; pos, len: longint; p: ptr): OSErr;
  25.     function FSSpecToFullPath (fs: FSSpec; var path: Str255): OSErr;
  26.     function DiskFreeSpace (vrn: integer): longint; { result in k }
  27.     function DiskSize (vrn: integer): longint; { result in k }
  28.     function BlessSystemFolder (vrn: integer; dirID: longint): OSErr;
  29.     function SameFSSpec (var fs1, fs2: FSSpec): boolean;
  30.     procedure GetSFLocation (var vrn: integer; var dirID: longint);
  31.     procedure SetSFLocation (vrn: integer; dirID: longint);
  32.     procedure SafeFindFolder (vRefNum: integer; folderType: OSType; var foundVRefNum: integer; var foundDirID: longint);
  33.     function CreateTemporaryFile (var fs: FSSpec): OSErr;
  34.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longint): OSErr;
  35.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longint): OSErr;
  36.  
  37. implementation
  38.  
  39.     uses
  40.         Errors, Packages, GestaltEqu, Folders, Aliases, LowMem, Devices,
  41.         MyTypes, TextUtils, MyStrings;
  42.  
  43.     procedure SafeFindFolder (vRefNum: integer; folderType: OSType; var foundVRefNum: integer; var foundDirID: longint);
  44.         var
  45.             theWorld: SysEnvRec;
  46.             gv: longint;
  47.     begin
  48.         foundVRefNum := -1;
  49.         foundDirID := 2;
  50.         if (Gestalt(gestaltFindFolderAttr, gv) <> noErr) | (not BTST(gv, gestaltFindFolderPresent)) | (FindFolder(vRefNum, folderType, true, foundVRefNum, foundDirID) <> noErr) then begin
  51.             if SysEnvirons(1, theWorld) = noErr then begin
  52.                 foundVRefNum := theWorld.sysVRefNum;
  53.                 foundDirID := 0;
  54.             end else begin
  55.                 foundVRefNum := -1;
  56.                 foundDirID := 2;
  57.             end;
  58.         end;
  59.     end;
  60.  
  61.     function CreateTemporaryFile (var fs: FSSpec): OSErr;
  62.     begin
  63.         SafeFindFolder(-1, kTemporaryFolderType, fs.vRefNum, fs.parID);
  64.         CreateTemporaryFile := CreateUniqueFile(fs, 'trsh', 'trsh');
  65.     end;
  66.  
  67.     procedure GetSFLocation (var vrn: integer; var dirID: longint);
  68.     begin
  69.         vrn:= -LMGetSFSaveDisk;
  70.         dirID:=LMGetCurDirStore;
  71.     end;
  72.  
  73.     procedure SetSFLocation (vrn: integer; dirID: longint);
  74.     begin
  75.         LMSetSFSaveDisk(vrn);
  76.         LMSetCurDirStore(dirID);
  77.     end;
  78.  
  79.     function FSSPecToFullPath (fs: FSSpec; var path: Str255): OSErr;
  80.         var
  81.             err: OSErr;
  82.             pb: CInfoPBRec;
  83.             s: str63;
  84.     begin
  85.         s := fs.name;
  86.         err := FSMakeFSSpec(fs.vRefNum, fs.parID, s, fs);
  87.         if err = fnfErr then begin
  88.             err := noErr;
  89.         end;
  90.         if err = noErr then begin
  91.             if fs.parID = 1 then begin
  92.                 path := concat(fs.name, ':');
  93.             end else begin
  94.                 path := fs.name;
  95.                 while (err = noErr) & (fs.parID <> 1) do begin
  96.                     err := FSpGetCatInfo(fs, -1, pb);
  97.                     path := concat(fs.name, ':', path);
  98.                     fs.parID := pb.ioFlParID;
  99.                 end;
  100.             end;
  101.         end;
  102.         FSSPecToFullPath := err;
  103.     end;
  104.  
  105.     function TouchDir (fs: FSSpec): OSErr;
  106.         var
  107.             pb: CInfoPBRec;
  108.             err: OSErr;
  109.     begin
  110.         if fs.name = '' then begin
  111.             TouchDir := TouchFolder(fs.vRefNum, fs.parID);
  112.         end else begin
  113.             pb.ioVRefNum := fs.vRefNum;
  114.             pb.ioDirID := fs.parID;
  115.             pb.ioNamePtr := @fs.name;
  116.             pb.ioFDirIndex := 0;
  117.             err := PBGetCatInfoSync(@pb);
  118.             if err = noErr then begin
  119.                 pb.ioNamePtr := nil;
  120.                 GetDateTime(pb.ioDrMdDat);
  121.                 err := PBSetCatInfoSync(@pb);
  122.             end;
  123.             TouchDir := err;
  124.         end;
  125.     end;
  126.  
  127.     function TouchFolder (vrn: integer; dirID: longint): OSErr;
  128.         var
  129.             pb: CInfoPBRec;
  130.             err: OSErr;
  131.     begin
  132.         pb.ioVRefNum := vrn;
  133.         pb.ioDirID := dirID;
  134.         pb.ioNamePtr := nil;
  135.         pb.ioFDirIndex := -1;
  136.         err := PBGetCatInfoSync(@pb);
  137.         if err = noErr then begin
  138.             pb.ioVRefNum := vrn;
  139.             pb.ioDirID := dirID;
  140.             pb.ioNamePtr := nil;
  141.             GetDateTime(pb.ioDrMdDat);
  142.             err := PBSetCatInfoSync(@pb);
  143.         end;
  144.         TouchFolder := err;
  145.     end;
  146.  
  147.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  148.         var
  149.             oname: str31;
  150.             n: Str255;
  151.             i: integer;
  152.             oe: OSErr;
  153.     begin
  154.         oname := fs.name;
  155.         LimitStringLength(oname, 27, '…');
  156.         oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  157.         i := 1;
  158.         while oe = dupFNErr do begin
  159.             NumToString(i, n);
  160.             fs.name := concat(oname, '#', n);
  161.             oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  162.             i := i + 1;
  163.         end;
  164.         CreateUniqueFile := oe;
  165.     end;
  166.  
  167.     function MyFSReadAt (refnum: integer; pos, len: longint; p: ptr): OSErr;
  168.         var
  169.             pb: ParamBlockRec;
  170.             oe: OSErr;
  171.     begin
  172.         pb.ioRefNum := refnum;
  173.         pb.ioBuffer := p;
  174.         pb.ioReqCount := len;
  175.         pb.ioPosMode := fsFromStart;
  176.         pb.ioPosOffset := pos;
  177.         oe := PBReadSync(@pb);
  178.         if (oe = noErr) & (pb.ioActCount <> len) then begin
  179.             oe := -1;
  180.         end;
  181.         MyFSReadAt := oe;
  182.     end;
  183.  
  184.     function MyFSReadLineEOL (refnum: integer; ch: char; var s: Str255): OSErr;
  185.         var
  186.             pb: ParamBlockRec;
  187.             err: OSErr;
  188.     begin
  189.         pb.ioRefNum := refnum;
  190. {$PUSH}
  191. {$R-}
  192.         pb.ioBuffer := @s[1];
  193.         pb.ioReqCount := SizeOf(s) - 1;
  194.         pb.ioPosMode := fsFromMark + fsNewLine + BSL(ord(ch), 8);
  195.         pb.ioPosOffset := 0;
  196.         err := PBReadSync(@pb);
  197.         if (err = eofErr) & (pb.ioActCount > 0) then begin
  198.             err := noErr;
  199.         end;
  200.         if err = noErr then begin
  201.             if s[pb.ioActCount] = ch then begin
  202.                 pb.ioActCount := pb.ioActCount - 1;
  203.             end;
  204.             s[0] := chr(pb.ioActCount);
  205.         end;
  206. {$POP}
  207.         MyFSReadLineEOL := err;
  208.     end;
  209.  
  210.     function MyFSReadLine (refnum: integer; var s: Str255): OSErr;
  211.     begin
  212.         MyFSReadLine := MyFSReadLineEOL(refnum, cr, s);
  213.     end;
  214.  
  215.     function MyFSReadLineAt (refnum: integer; pos: longint; var s: Str255): OSErr;
  216.         var
  217.             pb: ParamBlockRec;
  218.             err: OSErr;
  219.     begin
  220.         pb.ioRefNum := refnum;
  221. {$PUSH}
  222. {$R-}
  223.         pb.ioBuffer := @s[1];
  224.         pb.ioReqCount := SizeOf(s) - 1;
  225.         pb.ioPosMode := fsFromStart + fsNewLine + BSL(ord(cr), 8);
  226.         pb.ioPosOffset := pos;
  227.         err := PBReadSync(@pb);
  228.         if (err = eofErr) & (pb.ioActCount > 0) then begin
  229.             err := noErr;
  230.         end;
  231.         if err = noErr then begin
  232.             s[0] := chr(pb.ioActCount - 1);
  233.         end;
  234. {$POP}
  235.         MyFSReadLineAt := err;
  236.     end;
  237.  
  238.     function MyFSWrite (refnum: integer; len: longint; p: ptr): OSErr;
  239.         var
  240.             oe: OSErr;
  241.             count: longint;
  242.     begin
  243.         oe := noErr;
  244.         if len > 0 then begin
  245.             count := len;
  246.             oe := FSWrite(refnum, count, p);
  247.             if (oe = noErr) & (count <> len) then begin
  248.                 oe := -1;
  249.             end;
  250.         end;
  251.         MyFSWrite := oe;
  252.     end;
  253.  
  254.     procedure MyResolveAliasFile (var fs: FSSpec);
  255.         var
  256.             isfolder, wasalias: boolean;
  257.             temp: FSSpec;
  258.             gv: longint;
  259.             oe: OSErr;
  260.     begin
  261.         if (Gestalt(gestaltAliasMgrAttr, gv) = noErr) & (BTST(gv, gestaltAliasMgrPresent)) then begin
  262.             temp := fs;
  263.             oe := ResolveAliasFile(fs, true, isfolder, wasalias);
  264.             if oe <> noErr then begin
  265.                 fs := temp;
  266.             end;
  267.         end;
  268.     end;
  269.  
  270.     function MyGetCatInfo (vrn: integer; dirID: longint; var name: string; index: integer; var pb: CInfoPBRec): OSErr;
  271.     begin
  272.         pb.ioVRefNum := vrn;
  273.         pb.ioDirID := dirID;
  274.         pb.ioNamePtr := @name;
  275.         pb.ioFDirIndex := index;
  276.         MyGetCatInfo := PBGetCatInfoSync(@pb);
  277.     end;
  278.  
  279.     function FSpGetCatInfo (var fs: FSSpec; index: integer; var pb: CInfoPBRec): OSErr;
  280.     begin
  281.         pb.ioVRefNum := fs.vRefNum;
  282.         pb.ioDirID := fs.parID;
  283.         pb.ioNamePtr := @fs.name;
  284.         pb.ioFDirIndex := index;
  285.         FSpGetCatInfo := PBGetCatInfoSync(@pb);
  286.     end;
  287.  
  288.     function FSpSetCatInfo (var fs: FSSpec; var pb: CInfoPBRec): OSErr;
  289.     begin
  290.         pb.ioVRefNum := fs.vRefNum;
  291.         pb.ioDirID := fs.parID;
  292.         pb.ioNamePtr := @fs.name;
  293.         FSpSetCatInfo := PBSetCatInfoSync(@pb);
  294.     end;
  295.  
  296.     function MyFSMakeFSSpec (vrn: integer; dirID: longint; name: Str255; var fs: FSSpec): OSErr;
  297.         var
  298.             pb: CInfoPBRec;
  299.             oe: OSErr;
  300.             gv: longint;
  301.     begin
  302.         if (Gestalt(gestaltFSAttr, gv) = noErr) & (BTST(gv, gestaltHasFSSpecCalls)) then begin
  303.             oe := FSMakeFSSpec(vrn, dirID, name, fs);
  304.         end else begin
  305.             oe := MyGetCatInfo(vrn, dirID, name, 0, pb);
  306.             if (oe = noErr) then begin
  307.                 fs.vRefNum := pb.ioVRefNum;
  308.                 fs.parID := pb.ioFlParID;
  309.                 fs.name := name;
  310.             end;
  311.         end;
  312.         MyFSMakeFSSpec := oe;
  313.     end;
  314.  
  315.     procedure MyGetModDate (var fs: FSSpec; var moddate: longint);
  316.         var
  317.             oe: OSErr;
  318.             pb: CInfoPBRec;
  319.     begin
  320.         oe := MyGetCatInfo(fs.vRefNum, fs.parID, fs.name, 0, pb);
  321.         if oe = noErr then begin
  322.             moddate := pb.ioFlMdDat
  323.         end else begin
  324.             moddate := $80000000;
  325.         end;
  326.     end;
  327.  
  328.     function CopyData (src, dst: integer; len: longint): OSErr;
  329.         const
  330.             buffer_len = 4096;
  331.         var
  332.             buffer: array[1..buffer_len] of signedByte;
  333.             l: longint;
  334.             oe: OSErr;
  335.     begin
  336.         oe := noErr;
  337.         while (len > 0) & (oe = noErr) do begin
  338.             if len > SizeOf(buffer) then begin
  339.                 l := SizeOf(buffer);
  340.             end else begin
  341.                 l := len;
  342.             end;
  343.             oe := FSRead(src, l, @buffer);
  344.             if (l = 0) & (oe = noErr) then begin
  345.                 oe := -1;
  346.             end;
  347.             if oe = noErr then begin
  348.                 oe := MyFSWrite(dst, l, @buffer);
  349.             end;
  350.             len := len - l;
  351.         end;
  352.         CopyData := oe;
  353.     end;
  354.  
  355.     function DuplicateFile (var org, new: FSSpec): OSErr;
  356.         var
  357.             oe, ooe: OSErr;
  358.             fi: FInfo;
  359.             pb: CInfoPBRec;
  360.             orn, nrn: integer;
  361.             rlen, dlen: longint;
  362.     begin
  363.         oe := FSpGetFInfo(org, fi);
  364.         if oe = noErr then begin
  365.             oe := FSpCreate(new, fi.fdCreator, fi.fdType, 0);
  366.         end;
  367.         if oe = noErr then begin
  368.             oe := MyGetCatInfo(org.vRefNum, org.parID, org.name, 0, pb);
  369.             if oe = noErr then begin
  370.                 dlen := pb.ioFlLgLen;
  371.                 rlen := pb.ioFlRLgLen;
  372.                 pb.ioVRefNum := new.vRefNum;
  373.                 pb.ioDirID := new.parID;
  374.                 pb.ioNamePtr := @new.name;
  375.                 pb.ioFDirIndex := 0;
  376.                 oe := PBGetCatInfoSync(@pb);
  377.             end;
  378.  
  379.             if oe = noErr then begin
  380.                 oe := FSpOpenDF(org, fsRdPerm, orn);
  381.                 if oe = noErr then begin
  382.                     oe := FSpOpenDF(new, fsWrPerm, nrn);
  383.                     if oe = noErr then begin
  384.                         oe := CopyData(orn, nrn, dlen);
  385.                         ooe := FSClose(nrn);
  386.                         if oe = noErr then begin
  387.                             ooe := oe;
  388.                         end;
  389.                     end;
  390.                     ooe := FSClose(orn);
  391.                 end;
  392.             end;
  393.  
  394.             if oe = noErr then begin
  395.                 oe := FSpOpenRF(org, fsRdPerm, orn);
  396.                 if oe = noErr then begin
  397.                     oe := FSpOpenRF(new, fsWrPerm, nrn);
  398.                     if oe = noErr then begin
  399.                         oe := CopyData(orn, nrn, rlen);
  400.                         ooe := FSClose(nrn);
  401.                         if oe = noErr then begin
  402.                             ooe := oe;
  403.                         end;
  404.                     end;
  405.                     ooe := FSClose(orn);
  406.                 end;
  407.             end;
  408.  
  409.             if oe <> noErr then begin
  410.                 ooe := FSpDelete(new);
  411.             end;
  412.         end;
  413.         DuplicateFile := oe;
  414.     end;
  415.  
  416.     function MyFSWriteAt (refnum: integer; mode: integer; pos, len: longint; p: ptr): OSErr;
  417.         var
  418.             pb: ParamBlockRec;
  419.             oe: OSErr;
  420.     begin
  421.         pb.ioRefNum := refnum;
  422.         pb.ioBuffer := p;
  423.         pb.ioReqCount := len;
  424.         pb.ioPosMode := mode;
  425.         pb.ioPosOffset := pos;
  426.         oe := PBWriteSync(@pb);
  427.         if (oe = noErr) & (pb.ioActCount <> len) then begin
  428.             oe := -1;
  429.         end;
  430.         MyFSWriteAt := oe;
  431.     end;
  432.  
  433.     const
  434.         maxk = $70000000 div 1024;
  435.  
  436.     function MultiplyAllocation (blocks, blocksize: longint): longint; { result in k }
  437.         var
  438.             size: longint;
  439.     begin
  440.         blocks := BAND(BSR(blocks, 1), $00007FFF); { div 2 }
  441.         blocksize := BAND(BSR(blocksize, 9), $007FFFFF); { div 512 }
  442.         if (blocksize > 256) & (blocks > 256) then begin
  443.             size := (blocksize div 16) * (blocks div 16);
  444.             if size > maxk div 256 then begin
  445.                 size := maxk div 256;
  446.             end;
  447.             size := size * 256;
  448.         end else begin
  449.             size := blocksize * blocks; { in k }
  450.             if size > maxk then begin
  451.                 size := maxk;
  452.             end;
  453.         end;
  454.         MultiplyAllocation := size;
  455.     end;
  456.  
  457.  
  458.     function OldDiskFreeSpace (vrn: integer): longint; { result in k }
  459.         var
  460.             err: OSErr;
  461.             pb: HParamBlockRec;
  462.             free: longint;
  463.     begin
  464.         free := maxk;
  465.         pb.ioNamePtr := nil;
  466.         pb.ioVRefNum := vrn;
  467.         pb.ioVolIndex := 0;
  468.         err := PBHGetVInfoSync(@pb);
  469.         if err = noErr then begin
  470.             free := MultiplyAllocation(pb.ioVFrBlk, pb.ioVAlBlkSiz);
  471.         end;
  472.         OldDiskFreeSpace := free;
  473.     end;
  474.  
  475.     function DiskFreeSpace (vrn: integer): longint; { result in k }
  476.         var
  477.             err: OSErr;
  478.             free: longint;
  479.     begin
  480.         err := GetVInfo(vrn, nil, vrn, free);
  481.         if err <> noErr then begin
  482.             free := maxk;
  483.         end else begin
  484.             if free < 0 then begin
  485.                 free := maxk;
  486.             end else begin
  487.                 free := free div 1024;
  488.                 if free > maxk then begin
  489.                     free := maxk;
  490.                 end;
  491.             end;
  492.         end;
  493.         DiskFreeSpace := free;
  494.     end;
  495.  
  496.     function DiskSize (vrn: integer): longint; { result in k }
  497.         var
  498.             err: OSErr;
  499.             pb: HParamBlockRec;
  500.             size: longint;
  501.     begin
  502.         size := 0;
  503.         pb.ioNamePtr := nil;
  504.         pb.ioVRefNum := vrn;
  505.         pb.ioVolIndex := 0;
  506.         err := PBHGetVInfoSync(@pb);
  507.         if err = noErr then begin
  508.             size := MultiplyAllocation(pb.ioVNmAlBlks, pb.ioVAlBlkSiz);
  509.         end;
  510.         DiskSize := size;
  511.     end;
  512.  
  513.     function BlessSystemFolder (vrn: integer; dirID: longint): OSErr;
  514.         var
  515.             err: OSErr;
  516.             pb: HParamBlockRec;
  517.     begin
  518.         pb.ioNamePtr := nil;
  519.         pb.ioVRefNum := vrn;
  520.         pb.ioVolIndex := 0;
  521.         err := PBHGetVInfoSync(@pb);
  522.         if err = noErr then begin
  523.             pb.ioVFndrInfo[0] := dirID;  { ARGHHHHHHH! }
  524.             err := PBSetVInfoSync(@pb);
  525.         end;
  526.         BlessSystemFolder := err;
  527.     end;
  528.  
  529.     function SameFSSpec (var fs1, fs2: FSSpec): boolean;
  530.     begin
  531.         SameFSSpec := (fs1.vRefNum = fs2.vRefNum) & (fs1.parID = fs2.parID) & (IUEqualString(fs1.name, fs2.name) = 0);
  532.     end;
  533.  
  534.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longint): OSErr;
  535.         var
  536.             procID: longint;
  537.             oe: OSErr;
  538.     begin
  539.         oe := GetWDInfo(wdrn, vrn, dirID, procID);
  540.         if oe <> noErr then begin
  541.             vrn := wdrn;
  542.             dirID := 0;
  543.         end;
  544.         GetDirID := oe;
  545.     end;
  546.  
  547.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longint): OSErr;
  548.         var
  549.             pb: paramBlockRec;
  550.             oe: OSErr;
  551.     begin
  552.         if (name <> '') & (name[length(name)] <> ':') then begin
  553.             name := concat(name, ':');
  554.         end;
  555.         pb.ioNamePtr := @name;
  556.         pb.ioVRefNum := vrn;
  557.         pb.ioVolIndex := index;
  558.         oe := PBGetVInfoSync(@pb);
  559.         if oe = noErr then begin
  560.             vrn := pb.ioVRefNum;
  561.             CrDate := pb.ioVCrDate;
  562.         end;
  563.         GetVolInfo := oe;
  564.     end;
  565.  
  566. end.